perm filename SOLITA[1,BGB] blob sn#057499 filedate 1973-08-11 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00011 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ALTERNATE PDP-10 MNEMONICS.
C00005 00003	SAIL LIKE SUBROUTINE LINKAGE.
C00008 00004	TITLE SOLITA  -  JMC SOLITAIRE  -  B.G.BAUMGART  -  10 AUGUST 1973.
C00010 00005	MAIN EXECUTION.
C00012 00006	SUBR(LEGAL,Q)		SKIP WHEN MOVE IS ILLEGAL.
C00014 00007	SUBR(TRY)
C00016 00008	SUBR(RANDOM)
C00020 00009	SUBR(SHUFFL)
C00022 00010	SUBR(DECDPY,INTEGER)	DECIMAL NUMBER DISPLAY.
C00024 00011	SUBR(REALIN)
C00027 ENDMK
C⊗;
;ALTERNATE PDP-10 MNEMONICS.

	DEFINE O(A,B){OPDEF A[B]}
	O LIP,HLR↔O LAP,HRR↔O DIP,HRLM↔O DAP,HRRM
	O ZIP,HRRZS↔O ZAP,HLLZS↔O WIP,HRROS↔O WAP,HRRZS
	O CAR,HLRZ↔O LIPI,HRLI↔O LAPI,HRRI↔O DIPZ,HRLZM
	O CDR,HRRZ↔O LACI,MOVEI↔O SLACI,MOVSI↔O DAPZ,HRRZM
	O LAC,MOVE↔O LACN,MOVN↔O LACM,MOVM↔O SLAC,MOVS
	O DAC,MOVEM↔O DACN,MOVNM↔O DACM,MOVMM↔O SDAC,MOVSM
	O NIP,HLRE↔O NAP,HRRE↔O NIM,HRREI↔O GO,JRST
	O DZM,SETZM↔O DOM,SETOM↔O ZAC,SETZ↔O WAC,SETO
	O FLOAT,FSC 233↔O FLO,FSC 225↔O FIXX,FIX 233000

;MAKE RAID KNOW THE FOLLOWING

	O(FIX,FIX)↔O(HALT,HALT)
	O(INCHRW,INCHRW)↔O(INCHWL,{051200000000})
	O(OUTCHR,OUTCHR)↔O(OUTSTR,OUTSTR)
	O(JRSTF,{JRST 2,})↔O(JCALL,{JRST 1,})↔O(PGCLR,{PGIOT 2,})

;RETURN FROM AN N-ARGUMENT SUBROUTINE CALL.

	↓P←←17↔DEFINE POP0J <POPJ P,>
	↓POP1J.:SUB P,[2(2)]↔GO@2(P)↔DEFINE POP1J<GO POP1J.>
	↓POP2J.:SUB P,[3(3)]↔GO@3(P)↔DEFINE POP2J<GO POP2J.>
	↓POP3J.:SUB P,[4(4)]↔GO@4(P)↔DEFINE POP3J<GO POP3J.>
	↓POP4J.:SUB P,[5(5)]↔GO@5(P)↔DEFINE POP4J<GO POP4J.>

;ACCUMULATOR AND TEMPORARY DATA MANAGEMENT.

	DEFINE ACCUMULATORS(LIST){ACPTR←←2	;DECLARE ACCUMULATORS.
	FOR AC⊂(LIST)<AC←ACPTR↔ACPTR←←ACPTR+1↔>}
	FOR @$ I←0,16<AC.$I←I↔>		;ACCUMULATOR NAMES FOR RAID.
	DEFINE DECLARE (LIST){
	FOR VARNAM⊂(LIST)<VARNAM:0↔>}

	DEFINE CRLF{OUTSTR[BYTE(7)15,12]}
;SAIL LIKE SUBROUTINE LINKAGE.
	DEFINE ARG1<-1(P)>↔DEFINE ARG2<-2(P)>
	DEFINE ARG3<-3(P)>↔DEFINE ARG4<-4(P)>
	DEFINE CAT $(A,B){A$B}	;CONCATENATION.
	.PLEVEL←←0	;PDL BACK POINTER.
	.SLEVEL←←0	;DEPTH OF NESTED SUBROUTINE DECLARATIONS.

;SUBROUTINE DECLARATION MACROS  -  SUBR & ENDR.
;(Reminder: Right-arrow, "→" is FAIL's macro arg EVAL).
	DEFINE SUBR(NAME,X1,X2,X3,X4,X5)↔{BEGIN NAME↔INTERN NAME
	GLOBAL .PLEVEL↔GLOBAL .SLEVEL↔.SLEVEL←←.SLEVEL+1
	CAT(.SBR,→.SLEVEL)←←.PLEVEL     ↔.PLEVEL←←.PLEVEL+1
	IFDIF<><X1>{DEFARG(X1,→.PLEVEL) ↔.PLEVEL←←.PLEVEL+1
	IFDIF<><X2>{DEFARG(X2,→.PLEVEL) ↔.PLEVEL←←.PLEVEL+1
	IFDIF<><X3>{DEFARG(X3,→.PLEVEL) ↔.PLEVEL←←.PLEVEL+1
	IFDIF<><X4>{DEFARG(X4,→.PLEVEL) ↔.PLEVEL←←.PLEVEL+1
	IFDIF<><X5>{DEFARG(X5,→.PLEVEL) ↔.PLEVEL←←.PLEVEL+1}}}}}
	XWD 777000+.PLEVEL-CAT(.SBR,→.SLEVEL)-1,[SIXBIT|NAME|]↔↓NAME:;}

;DEFINE ARGUMENT NAME MACRO.
	DEFINE DEFARG(NAME,LEVEL){DEFINE NAME{LEVEL-.PLEVEL(17)}}

;SUBROUTINE TERMINATION MACRO.
	DEFINE ENDR{.PLEVEL←←CAT(.SBR,→.SLEVEL)
	.SLEVEL←←.SLEVEL-1↔LIT↔BLOCK 0↔BEND }

;SUBROUTINE CALLING MACROS  -  CALL & SETQ.
	DEFINE CALL(NAME,X1,X2,X3,X4,X5)
	{GLOBAL .SLEVEL,.PLEVEL↔.SLEVEL←←.SLEVEL+1
	CAT(.SBR,→.SLEVEL)←←.PLEVEL
	IFDIF<><X1>{PUSH P,X1↔.PLEVEL←.PLEVEL+1
	IFDIF<><X2>{PUSH P,X2↔.PLEVEL←.PLEVEL+1
	IFDIF<><X3>{PUSH P,X3↔.PLEVEL←.PLEVEL+1
	IFDIF<><X4>{PUSH P,X4↔.PLEVEL←.PLEVEL+1
	IFDIF<><X5>{PUSH P,X5↔.PLEVEL←.PLEVEL+1 }}}}}
	IFDIF<><NAME>{PUSHJ P,NAME }
	.PLEVEL←←CAT(.SBR,→.SLEVEL)↔.SLEVEL←←.SLEVEL-1}
	DEFINE SETQ(VAR,LIST){CALL(LIST)↔DAC 1,VAR}

;STACK ACCESSING MACROS  -  PUSHP & POPP.
	DEFINE PUSHP(ARG){PUSH P,ARG↔.PLEVEL←←.PLEVEL+1}
	DEFINE POPP(ARG) {POP  P,ARG↔.PLEVEL←←.PLEVEL-1}
TITLE SOLITA  -  JMC SOLITAIRE  -  B.G.BAUMGART  -  10 AUGUST 1973.

	ACCUMULATORS{S0,S1,S2,S3,S4,P1,P2,P3,P4,A1,B1,A2,B2}
 
;INPUT DECK.
	DECK0:	-1
	DECK:	BLOCK =52
	CNT:	0		;MOVE COUNTER.

;TEMPORARY STACKS.
	STAK1:	-1↔BLOCK =52
	STAK2:	-1↔BLOCK =52
	STAK3:	-1↔BLOCK =52
	STAK4:	-1↔BLOCK =52

;OUTPUT PILES.
	PILE1:	-1↔  0↔  1↔  2↔  3↔  4↔  5↔  6↔  7↔  8↔  9↔=10↔=11↔=12
	PILE2:	-1↔  1↔  3↔  5↔  7↔  9↔=11↔  0↔  2↔  4↔  6↔  8↔=10↔=12
	PILE3:	-1↔  2↔  5↔  8↔=11↔  1↔  4↔  7↔=10↔  0↔  3↔  6↔  9↔=12
	PILE4:	-1↔  3↔  7↔=11↔  2↔  6↔=10↔  1↔  5↔  9↔  0↔  4↔  8↔=12

;TABLE FOR CONVERTING BINARY TO HALFY.

TAB1:	XWD S1,P1↔XWD S1,P2↔XWD S1,P3↔XWD S1,P4
	XWD S2,P1↔XWD S2,P2↔XWD S2,P3↔XWD S2,P4
	XWD S3,P1↔XWD S3,P2↔XWD S3,P3↔XWD S3,P4
	XWD S4,P1↔XWD S4,P2↔XWD S4,P3↔XWD S4,P4
	XWD S0,S1↔XWD S0,S2↔XWD S0,S3↔XWD S0,S4
;MAIN EXECUTION.
	PDL:	BLOCK =2000

SA:	LACI =1000↔DAC CNT3
	DZM CNT1↔DZM CNT2

REPLAY:	SOSGE CNT3↔GO ENDUP
	LAC P,[XWD -=2000,PDL]
	LACI =104↔DAC CNT		;GAME HAS EXACTLY =104 MOVES.
	CALL(SHUFFL)

;INITIALIZE THE POINTERS.
	LAC S0,[XWD =52,DECK+=51]
	LACI S1,STAK1↔LACI P1,PILE1
	LACI S2,STAK2↔LACI P2,PILE2
	LACI S3,STAK3↔LACI P3,PILE3
	LACI S4,STAK4↔LACI P4,PILE4
	CALL(TRY)

LOSER:	AOS CNT1↔GO REPLAY
WINNER:	AOS CNT2↔GO REPLAY

ENDUP:
	CRLF↔CRLF
	OUTCHR[9]↔CALL(DECDPY,CNT1)↔OUTSTR[ASCIZ/ GAMES LOST.
/]↔	OUTCHR[9]↔CALL(DECDPY,CNT2)↔OUTSTR[ASCIZ/ GAMES WON.
/]↔	INCHRW↔GO SA

CNT1:	0
CNT2:	0
CNT3:	0

SUBR(LEGAL,Q)		;SKIP WHEN MOVE IS ILLEGAL.
COMMENT ⊗------------------------------------------------------------
⊗↔
	ACCUMULATORS{S0,S1,S2,S3,S4,P1,P2,P3,P4,A1,B1,A2,B2}
	
	CAR A1,Q↔LAC A2,(A1)		;SOURCE AC# AND PDLPTR.
	CDR B1,Q↔LAC B2,(B1)		;DESTIN AC# AND PDLPTR.

;IS SOURCE EMPTY ?
	DPB A1,[POINT 4,.+1,12]
	TLNN 0,-1↔GO L2			;EXIT NO CARD AT SOURCE.

;IS DESTINATION A PILE ?
	LAC(A2)			;GET SOURCE CARD
	CAIGE B1,P1↔GO L3
	CAME 1(B2)     		;COMPARE SOURCE WITH DESTINATION+1.
L2:	AOS(P)↔POP1J

;DESTINATION IS A STACK.
L3:	ADDI 0,TAB2
	CAME B1,@0
	AOS(P)↔POP1J

ENDR LEGAL;8/11/73(BGB)----------------------------------------------

;	 0  1  2  3  4  5  6  7  8  9 10 11 12	  ←←CARD.
TAB2:	S2↔S1↔S1↔S1↔S2↔S1↔S3↔S2↔S3↔S3↔S3↔S2↔S4;	  ←←STACK.
SUBR(TRY)
COMMENT ⊗------------------------------------------------------------
⊗
	PUSH P,[-1]↔LACI 1,=20

;GENERATE LEGAL MOVES AND PUSH THEM INTO THE STACK.
L1:	SOJL 1,L2
	CALL(LEGAL,{TAB1(1)})
	PUSH P,TAB1(1)↔GO L1

;ARE THERE ANY POSSIBLE MOVES LEFT.

L2:	SKIPGE(P)↔GO[POP P,0↔POP0J]	;EXIT TRIES EXHAUSTED.

;MOVE A CARD.
MOV:	CAR(P)↔DPB[POINT 4,.+3,12]
	CDR(P)↔DPB[POINT 4,.+2,12]
	POP↔PUSH

;CONTINUE GAME BELOW THIS PLY.
	SOSG CNT↔JCALL WINNER		;TEST FOR END OF GAME - WIN.
	CALL(TRY)

;UN-MOVE.
	CDR(P)↔DPB[POINT 4,.+5,12]
	CAR(P)↔DPB[POINT 4,.+4,12]
	CAIN S0↔GO LOSER		;TEST FOR END OF GAME - LOSE.
	POP↔PUSH↔AOS CNT

	POP P,0
	GO L2
ENDR TRY;8/11/73(BGB)------------------------------------------------
SUBR(RANDOM)
COMMENT ⊗------------------------------------------------------------
⊗
	SKIPE RANFLG↔GO L1		;TEST WHETHER WE ARE INIT'ED.

;INITIALIZE ARRAY RAN5 0 TO =255.
	SETOM RANFLG
	HRLZI 1,-=256↔LACI 3
	IMULI 3↔AND[017777777777]	;RAN5[I] ← RAN2 ←(RAN2*3)MOD 2↑31.
	DAC RAN5(1)↔AOBJN 1,.-3
	DAC RAN2↔LACI 1↔DAC RAN1	;RAN1 ← 1.

L1:	LAC 1,RAN2↔MULI 1,=1756		;RAN1 ← (RAN2*1756)MOD 8191.
	IDIVI 2,=8191↔DAC 3,RAN1

	LAC 1,RAN1↔ASH 1,-5		;RAN3 ← RAN1/32.
	CAILE 1,=256↔ANDI 1,377
	DAC 1,RAN3

	LAC RAN5(1)↔DAC RAN4		;RAN4 ← RAN5[RAN3];

	LAC RAN2
	IMULI 3↔AND[017777777777]	;RAN5[I] ← RAN2 ←(RAN2*3)MOD 2↑31.
	DAC RAN5(1)↔DAC RAN2

	LAC 1,RAN4↔ASH 1,-5↔FSC 1,201	;FLOAT TO REAL BETWEEN 0 AND 1.
	POP0J
DECLARE{RANFLG,RAN1,RAN2,RAN3,RAN4}
RAN5:	BLOCK =256
ENDR RANDOM;8/10/73(BGB)---------------------------------------------
SUBR(SHUFFL)
COMMENT ⊗------------------------------------------------------------
	Initialize the  input deck and  shuffle it by  calling RANDOM
52  times, placing  the cards in  the four  low order bits,  and then
sorting the deck.⊗

	I ←← 16		↔	J ←← 15
;GET 52 RANDOM NUMBER BETWEEN 0.0 AND 1.0 FLOATING.
	LACI I,=51			;52 CARDS TO A DECK.
	SLACI J,-=13			;13 CARDS TO A SUIT.
L1:	CALL(RANDOM)
	DPB J,[POINT 4,1,35]
	AOBJN J,.+2↔SLACI J,-=13	;BUMP THE CARD VALUE.
	DAC 1,DECK(I)
	SOJGE I,L1

;BUBBLE SORT THE CARDS.
	ZAC I,
L2:	LACI J,1(I)↔LAC DECK(I)
L3:	CAMG DECK(J)↔GO .+3
	EXCH DECK(J)↔DAC DECK(I)
	CAIGE J,=51↔AOJA J,L3
	CAIGE I,=50↔AOJA I,L2

;MASK THE CARDS.
	LAC I,[XWD -=52,DECK]↔LACI 17
	ANDM(I)↔AOBJN I,.-1
	POP0J
ENDR SHUFFL;8/10/73(BGB)---------------------------------------------
SUBR(DECDPY,INTEGER)	;DECIMAL NUMBER DISPLAY.
	LAC 1,INTEGER↔POPP -1(P)	;FETCH ARG AND LAC RET. ADR.
L1:	JUMPGE 1,L2			;TEST FOR NEGATIVE NUMBER.
	MOVM 2,1↔OUTCHR["-"]		;PRINT MINUS SIGN.
	LAC 1,2
L2:	IDIVI 1,12↔PUSH P,2		;MODULO TEN AND SAVE.
	SKIPE 1↔PUSHJ P,L2		;TEST FOR DONE.
	POP P,1↔ADDI 1,60↔OUTCHR 1	;RESTORE & PRINT.
	POP0J
ENDR DECDPY;12/17/72(BGB)--------------------------------------------

SUBR(FLODPY,FLONUM,PLACES)	;FLOATING NUMBER DISPLAY.
	LAC FLONUM
	JUMPL[OUTCHR["-"]↔LACM FLONUM↔GO .+1]
	LACM 2,PLACES↔CAILE 2,6↔LACI 2,6↔DAC 2,PLACES
	FMPR[1.↔10.↔100.↔1000.↔10000.↔100000.↔1000000.](2)↔FIXX
	IDIV[=1↔=10↔=100↔=1000↔=10000↔=100000↔=1000000](2)
	PUSHP 1↔CALL(DECDPY,0)↔POPP 0
	LAC 2,PLACES
	ADD[=1↔=10↔=100↔=1000↔=10000↔=100000↔=1000000](2)
	OUTCHR["."]↔CALL(DECDPY,0)
	POP2J
ENDR FLODPY;12/17/72(BGB)--------------------------------------------
SUBR(REALIN)
COMMENT ⊗------------------------------------------------------------
 <EXPR>		::= <EXPR>+<TERM>|<EXPR>-<TERM>|<TERM>
 <TERM>		::= <TERM>*<PRIMARY>|<TERM>/<PRIMARY>|<PRIMARY>
 <PRIMARY>	::= -<PRIMARY>|(<EXPR>)|π|<REAL NUMBER>
⊗
	CALL(TERM)↔CAIN 1,"+"
	GO [ PUSH P,0↔CALL(TERM)
	     FADR 0,(P)↔SUB P,[XWD 1,1]↔GO REALIN+1 ]
	CAIN 1,"-"
	GO [ PUSH P,0↔CALL(TERM)
	     MOVN 0,0↔FADR 0,(P)↔SUB P,[XWD 1,1]↔GO REALIN+1 ]
	CAIN 1,15↔INCHWL 1
	POP0J↔POP0J

TERM:	CALL(PRIMARY)
TERM2:	CAIN 1,"*"↔GO [ PUSH P,0↔CALL(PRIMARY)
	     FMPR 0,(P)↔SUB P,[XWD 1,1]↔GO TERM2 ]
	CAIN 1,"/"↔GO [ PUSH P,0↔CALL(PRIMARY)
	     EXCH 0,(P)↔FDVR 0,(P)↔SUB P,[XWD 1,1]
	     GO TERM2 ]
	POP0J
COMMENT ⊗ Input small real number.
	AC-0 INTEGER ACCUMULATION.	AC-0 RETURNS REAL NUMBER.
	AC-1 CHARACTER.		AC-1 RETURNS BREAK CHARACTER.
	AC-2 COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT PLUS ONE.
	AC-3 MINUS SIGN FLAG.
⊗
PRIMARY:SETZ↔SETZB 2,3
L0:	INCHWL 1
	CAIN 1," "↔GO .-2
	CAIN 1,"-"↔GO[SETCMM 3↔GO L0]
	CAIN 1,"π"↔GO[MOVE 0,[3.14159628]
	      GETRET: INCHWL 1↔GO L3]
	CAIN 1,"("↔GO[PUSH P,3↔CALL(REALIN)↔POP P,3
		      CAIN 1,")"↔GO GETRET
		      OUTSTR[ASCIZ/WARNING: MISSING ')'
/]↔		      POP0J]
	SKIPA
L1:	INCHWL 1
	CAIE 1,"."↔GO .+3↔JUMPN 2,L2↔AOJA 2,L1
	CAIL 1,"0"↔CAILE 1,"9"↔GO L2
	JUMPN 2,[CAILE 2,4↔GO L1↔AOJA 2,.+1]
	ANDI 1,17↔IMULI =10↔ADD 1↔GO L1
L2:	FLOAT↔SOSLE 2↔FDVR[1.0↔10.0↔100.0↔1000.0↔10000.0](2)
L3:	SKIPE 3↔MOVNS↔POP0J
ENDR REALIN;12/16/72(BGB),14-MAR-73(TVR)-----------------------------
END SA